home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr48 / proj3d.zip / PROJ3D.PAS < prev   
Pascal/Delphi Source File  |  1993-04-01  |  3KB  |  179 lines
  1. Program Projectile3d;
  2. uses Dos,graph,crt;
  3. var
  4.  Plasma: array[0..300,0..200] of byte;
  5.  
  6. procedure EgaVgaDriverProc; external;
  7. {$L C:\TP\BGI\EGAVGA.OBJ }
  8.  
  9. procedure Abort(Msg : string);
  10. begin
  11.   Writeln(Msg, ': ', GraphErrorMsg(GraphResult));
  12.   Halt(1);
  13. end;
  14.  
  15. Procedure init;
  16. var
  17.  gd,gm:integer;
  18.  c:integer;
  19. begin
  20.  if RegisterBGIdriver(@EGAVGADriverProc) < 0 then
  21.    Abort('EGA/VGA');
  22.  gd:=vga;
  23.  gm:=vgahi;
  24.  initgraph(gd,gm,'');
  25.  randomize;
  26. end;
  27.  
  28. Procedure defineit;
  29. var
  30.  A,B,C,D,N:integer;
  31.  l,m,q,o:word;
  32. begin
  33.  for A:=0 to 14 do
  34.  for B:=0 to 9 do
  35.     Begin
  36.      N:=random(255);
  37.      For c:=0 to 19 do
  38.      For d:=0 to 19 do
  39.         plasma[(A*20)+C,(B*20)+D]:=N;
  40.      End;
  41. GetTime(l,m,q,o);
  42. randseed:=l*m*q*o;
  43. randomize;
  44. end;
  45.  
  46.  
  47. function color(n:byte):byte;
  48. begin
  49.  case n of
  50.     11: color:=white;
  51.     10: color:=lightgray;
  52.     9: color:=lightred;
  53.     8: color:=red;
  54.     7: color:=brown;
  55.     6: color:=yellow;
  56.     5: color:=lightgreen;
  57.     4: color:=green;
  58.     3: color:=lightcyan;
  59.     2: color:=cyan;
  60.     1: color:=lightblue;
  61.     0: color:=blue
  62.  
  63.  end;
  64. end;
  65.  
  66. Procedure Showit;
  67. var
  68.  X,Y,A,B,C,D:integer;
  69. begin
  70.  clearviewport;
  71.  for y:=0 to 189 do
  72.   for x:=0 to 189 do
  73. begin
  74. { putpixel(150+X- (y div 8)+(plasma[x,y] div 10) ,
  75.            20+Y+ (x div 8)-(plasma[x,y] div 10),color(plasma[X,Y] div 26));}
  76.  
  77.  Setcolor(color(plasma[X,Y] div 21 ));
  78.  A:=150+X- (y div 8)+(plasma[x,y] div 8);
  79.  B:=20+Y+ (x div 8)-(plasma[x,y] div 8);
  80.  C:=150+X- (y div 8);
  81.  D:=20+Y+ (x div 8);
  82.  setwritemode(Normalput);
  83.  line(3*A-400,2*B,3*C-400,2*D);
  84.  {   putpixel(X,Y,plasma[X,Y] div 4);}
  85. end;
  86. end;
  87.  
  88. Procedure Q10across;
  89. var
  90.  X,Y,A,B,temp:integer;
  91. begin
  92.  for Y:=0 to 19  do
  93.   for X:=0 to 18 do
  94.     begin
  95.      temp:=(plasma[X*10,y*10]+plasma[(x+1)*10,y*10])  div 2;
  96.      for a:=0 to 9 do
  97.       for b:=0 to 9 do
  98.        begin
  99.          plasma[a+x*10,b+y*10]:=temp;
  100.          plasma[a+(X+1)*10,b+y*10]:=temp;
  101.        end;
  102.     end;
  103. end;
  104.  
  105. Procedure Q10down;
  106. var
  107.  X,Y,A,B,temp:integer;
  108. begin
  109.  for X:=0 to 19 do
  110.    for Y:=0 to 18  do
  111.     begin
  112.      temp:=(plasma[X*10,y*10]+plasma[x*10,(y+1)*10])  div 2;
  113.      for a:=0 to 9 do
  114.       for b:=0 to 9 do
  115.        begin
  116.          plasma[a+x*10,b+y*10]:=temp;
  117.          plasma[a+X*10,b+(y+1)*10]:=temp;
  118.        end;
  119.     end;
  120. end;
  121.  
  122. Procedure Qacross;
  123. var
  124.  X,Y,Temp:integer;
  125. begin
  126.  for Y:=0 to 199 do
  127.   for X:=0 to 198 do
  128.   begin
  129.    Temp:=(plasma[X,Y]+plasma[X+1,Y]) div 2;
  130.    plasma[x,y]:=temp;
  131.    plasma[x+1,y]:=temp;
  132.   end;
  133. end;
  134.  
  135. Procedure Qdown;
  136. var
  137.  X,Y,Temp:integer;
  138. begin
  139.   for X:=0 to 199 do
  140.   for Y:=0 to 198 do
  141.   begin
  142.    Temp:=(plasma[X,Y]+plasma[X,Y+1]) div 2;
  143.    plasma[x,y]:=temp;
  144.    plasma[x,y+1]:=temp;
  145.   end;
  146. end;
  147.  
  148.  
  149. Procedure Quantize;
  150. var c:integer;
  151. begin
  152.    q10across;
  153.    q10down;
  154.    qacross;
  155.    qdown;
  156.    qacross;
  157.    qdown;
  158.    qacross;
  159.    qdown;
  160.    qacross;
  161.    qdown;
  162.    qacross;
  163.    qdown;
  164.    qacross;
  165.    qdown;
  166. end;
  167.  
  168. begin
  169. init;
  170. defineit;
  171. Quantize;
  172. showit;
  173. repeat until keypressed;
  174. closegraph;
  175. Writeln('This program was created using Turbo Pascal V6.0');
  176. Writeln('Copyright Kevin Helman & Vector Graphics Associates 1992');
  177. Writeln('Feel Free to Distrubute this Program');
  178. end.
  179.